;;;          A simple transformer from object lisp (Acl 1.3.2) to clos (MCL 2.0b1)

;;; Author:  Karsten Poeck
;;; Address: Universitity of Karlsruhe
;;;          Institute for Logic
;;;          PoBox 6980
;;;          D 7500 Karlsruhe 1
;;;          Germany
;;; e-mail   poeck@ira.uka.de


;;; This code is in the public domain and is distributed without warranty
;;; of any kind. If you improve this, please send me a copy


#|

Description:
control-c-control-x:
Transforms selelected (defobject xxx....) (defobfun (exist xxx)) pair
into coresponding (defclass ) (defmethod initialize-instance)

control-c-control-y
Transforms selected s-expression from objectlisp to clos. This should be done
!!!after!!! transforming the coresponding (defobject xxx....) (defobfun (exist xxx)) pair.
Otherwise, references to object-lisp variables and functions
are not recognised and not transformed

control-c-control-s
Transforms all (defobject xxx....) (defobfun (exist xxx)) pairs
in the window

control-c-control-a
Transforms all s-expression in the window from objectlisp to clos
except for the (defobject xxx....) (defobfun (exist xxx)) pair,
which should be transformed earlierer

control-c-control-w
Transforms whole window from objectlisp to clos

control-c-control-
Transformiert die Umlaute eines Fensters nach ss,ae, ..

Configuration variables

(defvar *accessor_einbauen* t
  "Determines whether (accessor-function object) or (slotvalue object 'slot) is used")
(defvar *name-of-instance* 'ich
  "Determines the name of the instance in (defmethod xxx ((name_of_the_instance classs) ..) ..)")
;(setq *name-of-instance* 'self)


(defvar *compiler-option* :option
  "Determines if the 1.3.2 Code stays in #||# = :comment
  or is represented by #+:ccl-2 = :option
  or s deleted = :none"
  )
;(setq *compiler-option* :option)(setq *compiler-option* :comment)(setq *compiler-option* :none)

(defvar *capitalisieren* nil
  "Gibt an, ob der neue Code mit Grossbuchstaben beginnt")

Limitations:
This program does not make a semantical analysis and does know nothing
about lexical scope. If local variables
have the same names as objectlisp variables it is possible, that references
to this variables are mistransformed. The same holds for defuns

Bugs
:dialog-item-action #'(lambda() ..) is not
transformed to :dialog-item-action #'(lambda(self) ..)

Changes in defuns are not recognized (e.g (windows a b) --> (windows :class a :include-invisibles b))

Sometimes (normal-function ...) is transformed to (normal-function self ...)
e.g.

(modal-dialog a) -> (modal-dialog self a)

|#

(defvar *accessor_einbauen* t
  "Determines whether (accesor-function object) or (slotvalue object 'slot) is used")
;(setq *accessor_einbauen* t)(setq *accessor_einbauen* nil)

(defvar *name-of-instance* 'ich
  "Determines the name of the instance in (defmethod xxx ((name_of_the_instance classs) ..) ..)")
;(setq *name-of-instance* 'self)

(defvar *name-of-unknown-object* '!!!!!ich_weiss_nicht_welches_objekt!!!!)
;(setq *name-of-unknown-object* '!!!!dont_know_which_object!!!!)

(defvar *compiler-option* :option
  "Gibt an, ob der alte Code im Kommentar steht = :comment,
   in einer Compiler Option = :option,
   oder garnicht            = :none")
;(setq *compiler-option* :option)(setq *compiler-option* :comment)(setq *compiler-option* :none)

(defvar *capitalisieren* nil
  "Gibt an, ob der neue Code mit Grossbuchstaben beginnt")

;defines the keys

(setq *control-c-comtab* (make-comtab))

(comtab-set-key *comtab* '(:control #\c) *control-c-comtab*)

(Comtab-Set-Key *control-c-comtab* '(:control #\x) 'analysiere_struktur
                "Transformiert selektiertes defobject exist paar")

(Comtab-Set-Key *control-c-comtab* '(:control #\y) 'verzweige
                "Transformiert selektierten Ausdrcke ausser defobject und exist ")


(Comtab-Set-Key *control-c-comtab* '(:control #\s) 'transformiere_alle_defobjects_exists
                "Transformiert alle defobject exist Paare eines Fensters")

(Comtab-Set-Key *control-c-comtab*'(:control #\a) 'transnformiere_alle_sexp_in_fenster
                "Transformiert ein Fensters ausser defobject exist")

(Comtab-Set-Key *control-c-comtab*'(:control #\w) 'transnformiere_alles_im_fenster
                "Transformiert ein ganzes fenster")

(Comtab-Set-Key *control-c-comtab*'(:control #\) 'b=Umlaute-in-fenster-ersetzen
                "Transformiert die Umlaute eines Fensters")

(Comtab-Set-Key *control-c-comtab*'(:control #\r) 'transformator_ruecksetzen
                "Vergessen aller Information zum Transformieren")




(defun alle_obfuns_eines_ordnes_eintragen (ordner)
  "Merkt alle Objektdefinitionen in Ordner" 
  (dolist (datei (remove-duplicates (b=alle-dateien-im-ordner ordner)
                                    :test #'string-equal))
    (when (eql :text (mac-file-type datei))
    (let ((fenster (make-instance 'fred-window :filename datei :window-show nil)))
      (obfuns_eintragen fenster)
      (window-close fenster)))))
  
(defun die_slots_einer_klasse (klasse)
  (mapcar #'first (class-slots (find-class klasse))))

(defun mache_klassen_slots_bekannt (klasse)
  (merke klasse 'slots (die_slots_einer_klasse klasse)))

#|
Library functions used in the transformer
|#



(defmacro b=mit-#-lesen (&body body)
  `(labels (
            (
             tranform-semikolon-reader (stream char)
              (declare (ignore char))
              (do ((zeichen (read-char stream nil #\newline t) (read-char stream nil #\newline t))
                   (puffer ";" (b=konkateniere-nach-string puffer (b=erzeuge-string zeichen))
                           (b=konkateniere-nach-string puffer (b=erzeuge-string zeichen))))
                  ((char= #\newline zeichen)
                   puffer)))
            (
             make-point-reader (stream sub arg)
              (declare (ignore sub arg))
              (cons 'make-point (read stream t nil t)))
            )
     (let ((alte-semikolon-funktion (get-macro-character #\;))
           (alte-make-point-funktion (get-dispatch-macro-character #\# #\@))
           )
       (set-macro-character #\; #'tranform-semikolon-reader)
       (set-dispatch-macro-character #\# #\@ #'make-point-reader)
       (unwind-protect
         (progn
           ,@body)
         (set-macro-character #\; alte-semikolon-funktion)
         (set-dispatch-macro-character #\# #\@ alte-make-point-funktion)))))

(unless (fboundp 'b=Umlaute-in-Datei-ersetzen)
  (defun b=Umlaute-in-Datei-ersetzen (datei &key (fenster-zeigen-p))
    (let* ((fred-fenster (make-instance 'fred-window 
                                        :filename datei
                                        :window-show fenster-zeigen-p
                                        ;:view-position (b=Position-fuer-neues-Fenster :window-type 'fred-window)
                                        ))
           (der_buffer (fred-buffer fred-fenster))
           )
      (dolist (Umlautpaar `(("" "ae") ("" "ue") ("" "oe") ("" "Ae") ("" "Ue") ("" "Oe") ("" "ss")))
        (do* ((Umlaut (first Umlautpaar))
              (neuer-String (second Umlautpaar))
              (position (buffer-string-pos  der_buffer Umlaut :start 0 :end (buffer-size der_buffer)) 
                        (buffer-string-pos der_buffer Umlaut :start 0 :end (buffer-size der_buffer))))
             ((null position) nil)
          (b=Zeichen-im-buffer-ersetzen der_buffer Position neuer-String)
          (when fenster-zeigen-p
            (fred-update fred-fenster))
          )
        )
      (window-save fred-fenster)
      (window-close fred-fenster))))

(defmethod b=Umlaute-in-fenster-ersetzen ((fred-fenster fred-window))
  (let* ((der_buffer (fred-buffer fred-fenster)))
    (dolist (Umlautpaar `(("" "ae") ("" "ue") ("" "oe") ("" "Ae") ("" "Ue") ("" "Oe") ("" "ss")))
      (do* ((Umlaut (first Umlautpaar))
            (neuer-String (second Umlautpaar))
            (position (buffer-string-pos  der_buffer Umlaut :start 0 :end (buffer-size der_buffer)) 
                      (buffer-string-pos der_buffer Umlaut :start 0 :end (buffer-size der_buffer))))
           ((null position) nil)
        (b=Zeichen-im-buffer-ersetzen der_buffer Position neuer-String)))))

(unless (fboundp 'b=alle-Dateien-im-Ordner)
  (defun b=alle-Dateien-im-Ordner (Ordner)
    "Sucht alle Dateien im Ordner und seinen Unterordnern"
    (mapcar 
     #'(lambda (pathname)
         (mac-namestring pathname))
     (append 
      (apply #'append
             (mapcar #'(lambda (Unterordner)
                         (b=alle-Dateien-im-Ordner (b=konkateniere-nach-string Unterordner "*")))
                     (directory (b=konkateniere-nach-string Ordner "*") :directories T :files NIL)))
      (directory (b=konkateniere-nach-string Ordner "*") :directories NIL :files T))))
  )

(unless (fboundp 'B=JA-NEIN)
  (defun B=JA-NEIN (text &key (ja-text "JA")(nein-text "Nein" ))
    (let ((erg 
           (y-or-n-dialog text :yes-text ja-text :no-text nein-text)))
      (if erg :ja :nein))))

(unless (fboundp 'b=Zeichen-im-buffer-ersetzen)
  (defun b=Zeichen-im-buffer-ersetzen (buffer position neuer-String)
    (buffer-delete buffer position (+ position 1))
    (buffer-insert buffer neuer-String position)))


(defun b=string-im-buffer-ersetzen (buffer position alter-string neuer-String)
  (buffer-delete buffer  position (+ position (length alter-string)))
  (buffer-insert buffer neuer-String position))

(defun b=lese-sexp-aus-fenster (fenster start)
  (let ((start (buffer-skip-fwd-wsp&comments (fred-buffer fenster) start (buffer-size (fred-buffer fenster)))))
    (if start
      (buffer-current-sexp (fred-buffer fenster) start)
      nil)))

(unless (fboundp 'b=methode-p)
  (defun b=methode-p (symbol)
    (and (symbolp symbol)
         (fboundp symbol)
         (typep (symbol-function symbol) 'STANDARD-GENERIC-FUNCTION))))

(unless (fboundp 'b=lese-von-String)
  (defun b=lese-von-String (string)
    ;Ausgabe: liest ersten Lispausdruck von String string und wandelt ihn um
    ;         wenn string kein String ist, wird string zurueckgegeben
    ;Autor: Karsten
    (values
     (cond ((not (stringp string)) string)
           ((string-equal string ":") `|:|)
           ((b=Leerstring-p string) nil)
           (T (read-from-string string))))))

(unless (fboundp 'b=Leerstring-p)
  (defun b=Leerstring-p (String)
    "liefert t, wenn der String String nur Leerzeichen enthaelt bzw \"\" ist
   nil sonst"
    ;Autor: Ute, Datum: Feb. 90
    ;(string= (string-trim `(#\Space) String) ""))
    (not (find-if #'(lambda (item)
                      (not (string= item #\Space)))
                  String))))

(unless (fboundp 'b=union)
  (defun b=union (&rest Listen)
    "Wie union, aber auch fuer n Listen"
    ;Karsten 9.9.90
    (cond ((>= (length listen) 2)
           (reduce  'union Listen))
          (t (first listen)))
    ))

(unless (fboundp 'b=String-nach-Liste)
  (defun b=String-nach-Liste (String)
    "Ausgabe: Eine Liste aus den durch Leerzeichen getrennten Lispausdruecken des Strings String"
    ;z.B. "12  (2 3) ksjdf" -> (12 (2 3) ksjdf)
    ;     "(1 2 3)"         -> ((1 2 3))
    ;     ""                -> nil
    ;Autor: Ute, Datum: Feb. 90
    (b=lese-von-String (b=konkateniere-nach-String #\( String #\) ))))

(unless (fboundp 'b=konkateniere-nach-String)
  (defun b=konkateniere-nach-String (&rest Parameter)
    ;Eingabe: Beliebig viele Parameter
    ;Ausgabe: Konkatenierter String
    ;Autor: Karsten        
    (reduce #'(lambda(a b)
               (concatenate `string a b))
            (mapcar #'(lambda(was)
                       (if (stringp was)
                         was
                         (b=erzeuge-string was)))
                    parameter))))

(unless (fboundp 'b=erzeuge-String)
  (defun b=erzeuge-String (irgendetwas)
    ;Ausgabe: macht aus irgendwas einen String, nil wird zu ""
    ;Autor: Karsten
    (cond   ((keywordp irgendetwas)(format nil "~s" irgendetwas))
            ((null irgendetwas) "")
            ((symbolp irgendetwas) (string irgendetwas))
            ((stringp irgendetwas) irgendetwas)
            ((typep irgendetwas 'Character)(string irgendetwas))
            (t (format nil "~a" irgendetwas)))))

(defmethod transformator_ruecksetzen ((ich fred-window))
  (init_merker))

(defmethod map-sexp ((ich fred-window) funktion)
  (let ((position 0)
        ergebnis)
    (loop
      (multiple-value-bind 
        (ausdruck ende)
        (b=lese-sexp-aus-fenster ich position)
        (setq position (buffer-current-sexp-start (fred-buffer ich) ende))
        (if ausdruck
          (push (funcall funktion ausdruck position) ergebnis)
             (return (reverse ergebnis)))
           (setq position ende)
     ))))


;(transformiere_datei (choose-file-dialog))


(defun transformiere_datei (datei suffix)
  ;ersetze Umlaute
  ;kopiere Datei
  
  ;konvertiere alle defobjet exist in neuer DAtei
  ;konvertiere rest
  (init_merker)
  (when (fboundp 'B=UMLAUTE-IN-DATEI-ERSETZEN)
    (b=Umlaute-in-Datei-ersetzen datei))
  (let* ((altes_fenster
          (make-instance 'fred-window :filename datei))
         (neues_fenster 
          (make-instance 'fred-window :filename datei)))
    (set-window-filename neues_fenster 
                         (b=konkateniere-nach-string 
                          (window-filename neues_fenster) suffix))
    (set-selection-range neues_fenster)
    (transformiere_alle_defobjects_exists altes_fenster neues_fenster)
    ;jetzt fehlt noch der rest
    (window-close altes_fenster)
    (transnformiere_alle_sexp_in_fenster neues_fenster)
    )
  )

(defmethod transnformiere_alles_im_fenster ((ich fred-window))
  (b=Umlaute-in-fenster-ersetzen ich)
  (transformiere_alle_defobjects_exists ich)
  (transnformiere_alle_sexp_in_fenster ich)
  )

(defun transformiere_alle_defobjects_exists (altes_fenster &optional neues_fenster)
  (let ((hilfsfenster (not neues_fenster)))
    (when  hilfsfenster
      ;lege eine Kopie des ersten Fensters an
      (setq neues_fenster
            (kopiere_fenster altes_fenster)))
    (obfuns_eintragen altes_fenster)
    (b=mit-#-lesen
      (let ((liste (alle_defobject_exist_paare altes_fenster)))
        (do* ((restliste liste (cddr restliste))
              (klasse (first restliste)(first restliste))
              (posdefobjekt (getf (getf liste klasse) 'DEFOBJECT_POSITION) (getf (getf liste klasse) 'DEFOBJECT_POSITION))
              (posexist (getf (getf liste klasse) 'EXIST_POSITION) (getf (getf liste klasse) 'EXIST_POSITION)))
             ((endp restliste))
          (transformiere_ein_objekt altes_fenster neues_fenster klasse
                                    posdefobjekt posexist)
          (set-mark (fred-display-start-mark neues_fenster) posdefobjekt)
          (fred-update neues_fenster))
        ))
    (when hilfsfenster
      ;loesche Inhalt altes Fenster
      (buffer-delete (fred-buffer altes_fenster) 0 (buffer-size (fred-buffer altes_fenster)))
      (buffer-insert (fred-buffer altes_fenster)
                     (buffer-substring  (fred-buffer neues_fenster) (buffer-size (fred-buffer neues_fenster)) 0)
                     0)
      (window-close neues_fenster)
      (fred-update altes_fenster))
    )
  )

(defun kopiere_fenster (fenster)
  (let ((erg (make-instance 'fred-window :scratch-p t)))
    (buffer-insert (fred-buffer erg)
                   (buffer-substring (fred-buffer fenster) (buffer-size (fred-buffer fenster)) 0) 0)
    erg))

(defun transnformiere_alle_sexp_in_fenster (fenster)
  (let ((position 0)
        (buffer (fred-buffer fenster)))
    (b=mit-#-lesen
      (loop
        (multiple-value-bind 
          (ausdruck ende)
          (b=lese-sexp-aus-fenster fenster position)
          (setq position ende)
          (cond (ausdruck
                 (multiple-value-bind
                   (von bis)
                   (buffer-current-sexp-bounds buffer position)
                   (if (and (listp ausdruck)
                            (member (first ausdruck) '(Defclass Defmethod)))
                     nil
                     (let ((laenge (transformiere_eine_sexp fenster ausdruck von bis)))
                       (setq position (+ laenge von))))
                   (set-mark (fred-display-start-mark fenster) von)
                   (fred-update fenster))
                 )
                (t (return :ende)))))))
  )

(defun transformiere_eine_sexp (fenster ausdruck position ende)
  ;In fenster beginnt in position eine neue Sexp zwischen position und ende ,die Transformiert werden soll
  (let* ((buffer (fred-buffer fenster))
         (alter_string (buffer-substring buffer ende position))
         (neuer_string (lisp_nach_string
                        (transformiere_aussen *name-of-unknown-object* *name-of-unknown-object* ausdruck)))
         )
    
    (when (and (> (length neuer_string) 2)
               (char= (char neuer_string 1) #\")
               (char= (char neuer_string (- (length neuer_string) 2))))
      (setq neuer_string (substitute  #\; #\" neuer_string)))
    (setq neuer_string
          (case *compiler-option*
            (:option
             (b=konkateniere-nach-string
              #\newline "#-:ccl-2" #\newline alter_string #\newline #\newline
              "#+:ccl-2" #\newline neuer_string #\newline))
            (:comment 
             (b=konkateniere-nach-string
              "#|" #\newline alter_string #\newline "|#" #\newline
              neuer_string))
            (T neuer_string)))
    
    (let ((laenge (length neuer_string)))
      (b=string-im-buffer-ersetzen buffer position alter_string neuer_string)
      (if *capitalisieren*
        (buffer-capitalize-region buffer position (+ position laenge))
        (buffer-downcase-region buffer position (+ position laenge)))
      (length neuer_string)
      )))
      
(defun transformiere_ein_objekt (altes_fenster neues_fenster klassenbezeichner defobjektposition existposition)
  (declare (ignore KLASSENBEZEICHNER))
  (let* ((alter_buffer (fred-buffer altes_fenster))
         (neuer_buffer (fred-buffer neues_fenster))
         (defobjektliste (buffer-current-sexp alter_buffer defobjektposition))
         (existliste (buffer-current-sexp alter_buffer existposition))
         (defobjektstring 
           (buffer-substring alter_buffer (buffer-fwd-sexp alter_buffer defobjektposition) defobjektposition))
         (existstring 
          (buffer-substring alter_buffer (buffer-fwd-sexp alter_buffer existposition) existposition))
         (defobjektposition_neu ;position im neuen Fenster
           (buffer-string-pos neuer_buffer defobjektstring :start 0 :end (buffer-size neuer_buffer)))
         (existposition_neu ;position im neuen Fenster
          (buffer-string-pos neuer_buffer existstring :start 0 :end (buffer-size neuer_buffer)))
         )
    (analysiere_defobject defobjektliste)
    
    (when (null existposition)
      (setq existposition_neu -1)
      (setq existstring ""))
    
    (analysiere_exist existliste)
    (let* ((defclassstring (gebe_ergebnis_aus (lese_aktuelle_klasse)))
           (initializestring (gebe_exist_aus (lese_aktuelle_klasse)))
           (neuer_defobjecttext
            (case *compiler-option*
              (:option
               (b=konkateniere-nach-string 
                "#-:ccl-2" #\newline defobjektstring #\newline #\newline 
                "#+:ccl-2" #\newline defclassstring #\newline))
              (:comment
               (b=konkateniere-nach-string 
                "#|" #\newline defobjektstring #\newline "|#" #\newline defclassstring #\newline))
              (T defclassstring)))
           (neuer_existstring
            (if (minusp existposition_neu)
              ""
              (case *compiler-option*
                (:option
                 (b=konkateniere-nach-string
                  "#-:ccl-2" #\newline existstring #\newline #\newline
                  "#+:ccl-2" #\newline initializestring #\newline))
                (:comment
                 (b=konkateniere-nach-string
                  "#|" #\newline existstring #\newline "|#" #\newline initializestring #\newline))
                (T initializestring))))
           (exist_versatz (- (length neuer_defobjecttext)(length defobjektstring)))
           (anfang_defclass (+ defobjektposition_neu
                               (case *compiler-option*
                                 (:option (+ (length defobjektstring) 7))
                                 (:comment (+ (length defobjektstring) 19))
                                 (T 0))))
           
           (ende_defclass (+ defobjektposition_neu (length neuer_defobjecttext)))
           (anfang_initialize 
            (+ existposition_neu exist_versatz 
               (case *compiler-option*
                 (:option (+ (length existstring) 7))
                 (:comment (+ (length existstring) 19))
                 (T 0))))
           (ende_initialize 
            (+ existposition_neu exist_versatz (length neuer_existstring))))
      (b=string-im-buffer-ersetzen neuer_buffer defobjektposition_neu defobjektstring neuer_defobjecttext)
      (if *capitalisieren*
        (buffer-capitalize-region neuer_buffer anfang_defclass ende_defclass)
        (buffer-downcase-region neuer_buffer anfang_defclass ende_defclass))
      (unless (minusp existposition_neu)
        (b=string-im-buffer-ersetzen neuer_buffer (+ existposition_neu exist_versatz) existstring neuer_existstring)
        (if *capitalisieren*
          (buffer-capitalize-region neuer_buffer anfang_initialize ende_initialize)
          (buffer-downcase-region neuer_buffer anfang_initialize ende_initialize)))
      );let*
    );let*
  nil)

(defvar *der_merker* nil)
(defvar *alte_neue_funktionsnamen* nil)

(defmethod verzweige ((ich fred-window))
  (analysiere_struktur ich 'methoden))

(defmethod analysiere_struktur ((ich fred-window) &optional art)
  (b=mit-#-lesen
    (multiple-value-bind
      (von bis)
      (selection-range ich)
      (cond ((eql von bis)
             (ed-beep))
            (t 
             (case art
               (methoden
                (transformiere_eine_sexp ich (buffer-substring (fred-buffer ich) von bis) von bis)
                )
               (t 
                ;(init_merker)
                (obfuns_eintragen ich)
                (analysiere_text (buffer-substring (fred-buffer ich) von bis) ich)
                (buffer-insert (fred-buffer ich) "#|
"
                               von)
                (buffer-insert (fred-buffer ich) "
|#
"
                               (+ 3 bis))))))
      )))

(defun analysiere_text (text &optional fenster)
  (let ((liste (b=String-nach-Liste text)))
    (dolist (element liste)
      (cond ((listp element)
             (cond ((eql (first element) 'defobject)
                    (analysiere_defobject element))
                   ((and (eql (first element) 'defobfun)
                         (listp (second element))
                         (eql (first (second element)) 'exist))
                    (analysiere_exist element)))))))
  (let ((string (gebe_alle_ergebnisse_aus)))
    (if fenster
      (fuege_ergebnis_ein fenster string)
      (print string))))

 (defmethod fuege_ergebnis_ein ((ich fred-window) text)
   (when (and (> (length text) 2)
              (char= (char text 1) #\")
              (char= (char text (- (length text) 2))))
     (setq text (substitute  #\; #\" text)))
  (let ((laenge (length text))
        (wo (second (multiple-value-list (selection-range ich)))))
     (buffer-insert (fred-buffer ich) text wo)
    (buffer-capitalize-region (fred-buffer ich) wo (+ wo laenge))
   
    (fred-update ich)))

(defmethod alle_obfuns_paare ((ich fred-window))
  (remove nil
          (map-sexp ich
                    #'(lambda(sexp wo)
                       (declare (ignore wo))
                       (if (and (listp sexp)
                                   (eql (first sexp) 'defobfun))
                              (second sexp))))))

(defmethod alle_obfuns ((ich fred-window))
  (let ((alle (alle_obfuns_paare ich))
        (obfuns nil))
    (dolist (paar alle obfuns)
      (push (first paar)
            (getf obfuns (second paar))))))

(defmethod alle_defobject_exist_paare ((ich fred-window))
  (let (klasse-exist-alist)
    (map-sexp ich
              #'(lambda(ausdruck wo)
                 (cond  
                  ((and (listp ausdruck)
                        (eql (first ausdruck) 'defobject))
                   (setf (getf (getf klasse-exist-alist (second ausdruck)) 'defobject_position)
                         wo))
                  ((and (listp ausdruck)
                        (eql (first ausdruck) 'defobfun)
                        (eql 'exist (first (second ausdruck))))
                   (setf (getf (getf klasse-exist-alist (second (second ausdruck))) 'exist_position)
                         wo)))))
    (b-drehe_doppelliste klasse-exist-alist))
  )
                         
  
(defun b-drehe_doppelliste (liste)
  (if (null liste)
    nil
    (append (b-drehe_doppelliste (cddr liste)) (list (first liste)(second liste)))))

(defmethod obfuns_eintragen ((ich fred-window))
  "Merkt alle Objektdefinitionen in Fenster" 
  (do ((was (alle_obfuns ich) (cddr was)))
      ((endp was))
    (merke (first was) 'obfuns 
           (union (second was) (lese (first was) 'obfuns)))))

(defun init_merker ()
  (setq *der_merker* nil))

(defun merke (objektklasse eigenschaft wert)
  (setf (getf (getf *der_merker* objektklasse) eigenschaft) wert))

(defun merke_aktuelle_klasse (klasse)
  (merke 'aktuelle_klasse 'aktuelle_klasse klasse))

(defun lese_aktuelle_klasse ()
  (lese 'aktuelle_klasse 'aktuelle_klasse ))

(defun lese (objektklasse eigenschaft)
  (getf (getf *der_merker* objektklasse) eigenschaft))

(defun lese_bekannte_klassen ()
  (do ((merker)
       (liste *der_merker* (cddr liste)))
      ((endp liste) merker)
    (push (first liste) merker)))

(defun lese_alle (eigenschaft)
  (apply #'b=union
         (mapcar #'(lambda(was)
                    (lese was eigenschaft))
                 (lese_bekannte_klassen))))
 
(defun analysiere_defobject (liste)
  (when (and (eql (first liste) 'defobject)
             (>= (length liste) 2))
    (merke (second liste) 'eltern (mapcar #'transformiere_klassennamen (nthcdr 2 liste)))
    (merke_aktuelle_klasse (second liste))))

(defun analysiere_exist (liste)
  (when (and (listp liste)
             (eql (first liste) 'defobfun)
             (listp (second liste)))
    (let ((klasse (second (second liste))))
      (analysiere_rekursiv klasse (nthcdr 2 liste))
      (anaylisiere_2 liste))))

(defun anaylisiere_2 (liste)
  (merke (second (second liste)) 'exist
         `(defmethod initialize-instance ((,*name-of-instance*,(second (second liste))) &rest ,(first (third liste)))
            ,@(transformiere_aussen (second (second liste)) *name-of-instance*
                             (remove nil (analysiere_rekursiv_2 (second (second liste))(nthcdr 3 liste)))))))

(defun analysiere_rekursiv (klasse liste)
  (cond ((null liste) nil)
        ((atom liste) nil)
        ((eql 'have (first liste))
         (anlysiere_have klasse liste))
        ((atom (first liste))
         (analysiere_rekursiv klasse (rest liste)))
        ((listp (first liste))
         (analysiere_rekursiv klasse (first liste))
         (analysiere_rekursiv klasse (rest liste)))))

(defun analysiere_rekursiv_2 (klasse liste)
  (cond ((null liste) nil)
        ((atom liste) liste)
        ((eql 'have (first liste))
         ;ist es schon als default im defclass ?
         (if (or (neq :nicht-nil-ist-der-wert (getf (lese klasse (second (second liste))) :initform :nicht-nil-ist-der-wert))
                 (getf (lese klasse (second (second liste))) :initarg))
           nil
           (list 'setq (second (second liste)) (third liste))))
        ((eql 'usual-exist (first liste))
         `(apply #'call-next-method ,*name-of-instance*
                 ,(second liste)))
        ((atom (first liste))
         (cons (first liste) (analysiere_rekursiv_2 klasse (rest liste))))
        ((listp (first liste))
         (cons (analysiere_rekursiv_2 klasse (first liste))
               (analysiere_rekursiv_2 klasse (rest liste))))))

(defun potentiell_complex-p (liste)
  (and liste
       (listp liste)
       (neq 'quote (first liste))))

(defun anlysiere_have (klasse liste)
  (when (and (listp liste)
             (eql (first liste) 'have)
             (listp (second liste)))
    (let ((name (second (second liste)))
          default
          uebergabename
          (restliste (cddr liste)))
      (cond ((atom (first restliste))
             (setq default (first restliste)))
            ((eql 'getf (caar restliste))
             (setq uebergabename (third (first restliste))
                   default (fourth (first restliste))))
            (t ;also z.b have 'wert (+ 4 5)
             (setq default
                   (if (POTENTIELL_COMPLEX-P (first restliste))
                     :kein-default-vorhanden
                     (first restliste)))))
      (let ((die_liste nil))
        (when uebergabename
          (setq die_liste (append die_liste (list :initarg uebergabename))))
        (unless (eql :kein-default-vorhanden default)
          (setq die_liste (append die_liste (list :initform default))))
        (when *accessor_einbauen*
          (setq die_liste (append die_liste (list :accessor name))))
        (merke klasse name
               die_liste))
      (merke klasse 'slots (cons name (lese klasse 'slots)))
      )))
    
(defun gebe_ergebnis_aus (klasse)
  (let (slotliste)
    (dolist (slot (remove-duplicates (lese klasse 'slots)))
      (let ((sloteintrag (lese klasse slot)))
        (when (and (getf sloteintrag :INITFORM )
                   (listp (getf sloteintrag :INITFORM )))
          (setf (getf sloteintrag :INITFORM )
                (transformiere_aussen *name-of-unknown-object* *name-of-unknown-object* (getf sloteintrag :INITFORM ))))
        (push (cons slot sloteintrag) slotliste)))
    (lisp_nach_string `(defclass ,klasse ,(lese klasse 'eltern)
                         ,slotliste))
    
    ))

(defun gebe_exist_aus (klasse)
  (lisp_nach_string (lese klasse 'exist)))
       

(defun lisp_nach_string (was)
  (let ((fenster (make-instance 'fred-window :view-size (make-point 600 400)
                                :window-show nil :scratch-p t)))
    (pprint was fenster)
    (prog2
     (loop
       (let ((wo
              (buffer-string-pos (fred-buffer fenster) "\";" :start 0)))
         (cond (wo
                (multiple-value-bind
                  (anfang ende)
                  (buffer-current-sexp-bounds (fred-buffer fenster) wo)
                  (buffer-delete (fred-buffer fenster) anfang (1+ anfang))
                  (buffer-delete (fred-buffer fenster) (- ende 2) (1- ende))
                  (buffer-insert (fred-buffer fenster) "
 "
                                 (- ende 2))))
               (t
                (select-all fenster)
                (ed-indent-for-lisp fenster)
                (return)))))
     (buffer-substring (fred-buffer fenster) (1- (buffer-size (fred-buffer fenster))) 1)
     (window-close fenster)
     )))

(defun gebe_alle_ergebnisse_aus ()
  (b=konkateniere-nach-string 
   #\newline
   (gebe_ergebnis_aus (lese_aktuelle_klasse))
    #\newline
    (gebe_exist_aus (lese_aktuelle_klasse))
    #\newline))

(defun analysiere_rekursiv (klasse liste)
  (cond ((null liste) nil)
        ((atom liste) nil)
        ((eql 'have (first liste))
         (anlysiere_have klasse liste))
        ((atom (first liste))
         (analysiere_rekursiv klasse (rest liste)))
        ((listp (first liste))
         (analysiere_rekursiv klasse (first liste))
         (analysiere_rekursiv klasse (rest liste)))))

(defun transformiere_aussen (klasse idenfizierer liste)
  (let ((ergebnis (transformiere klasse idenfizierer liste)))
    (if (listp ergebnis)
      ergebnis
      ergebnis)))

(defun transformiere (klasse idenfizierer liste)
  (cond ((null liste) nil)
        ((atom liste) (transformiere_atom klasse idenfizierer liste))
        ((atom (first liste))
         (case (first liste)
           (have (transformiere_have klasse idenfizierer liste))
           (setq (transformiere_setq klasse idenfizierer liste))
           (ask (transformiere_ask klasse idenfizierer liste))
           (oneof (transformiere_oneof klasse idenfizierer liste))
           (defobfun (transformiere_defobfun klasse idenfizierer liste))
           (defun (transformiere_defun klasse idenfizierer liste))
           (objvar (transformiere_objvar  klasse idenfizierer liste))
           (declare (transformiere_declare klasse idenfizierer liste))
           (proclaim (transformiere_proclaim  klasse idenfizierer liste))
           (self (transformiere_self  klasse idenfizierer liste))
           (cond (transformiere_cond klasse idenfizierer liste))
           (case (transformiere_case klasse idenfizierer liste))
           (apply (transformiere_apply klasse idenfizierer liste))
           (funcall (transformiere_funcall klasse idenfizierer liste))
           ((ownp fboundp boundp eval makunbound fmakunbound)
            (transformiere_seltsam klasse idenfizierer liste))
           (quote liste)
           ;(modal-dialog (transformiere_modal-dialog klasse idenfizierer liste))
           ((let let*) (transformiere_let_let* klasse idenfizierer liste))
           ((do do*) (transformiere_do_do* klasse idenfizierer liste))
           ((dolist dotimes) (transformiere_dolist_dotimes klasse idenfizierer liste))
           (t (transformiere_methoden klasse idenfizierer liste))))
        (T (cons (transformiere  klasse idenfizierer (first liste))
                 (transformiere  klasse idenfizierer (rest liste)))))
  
  )

(defun transformiere_seltsam (klasse identifizierer liste)
  (let ((erg (transformiere_methoden klasse identifizierer liste)))
    (pprint `(Achtung ,klasse ,identifizierer ,liste -> ,erg))
    erg
    )
  )

(defun transformiere_modal-dialog (klasse idenfizierer liste)
  (declare (ignore klasse idenfizierer liste))
  ;(modal-dialog fenster &optional close)
  )


 (defun transformiere_apply (klasse idenfizierer liste &optional (fname 'apply))
  ;falls apply 'methode, oder #'methode muss funktionsname transformiert werden und idenfizierer eingefuegt wrden
  (cond ((and (listp liste)(listp (second liste))
              (eq (first (second liste)) 'quote)
              (EVENTUELL-METHODE-P nil  (second (second liste))))
         `(,fname ',(transformiere_funktionsnamen (second (second liste))) ,idenfizierer
                 ,@ 
           (mapcar #'(lambda(was)
                      (transformiere klasse idenfizierer was))
                   (cddr liste))))
        ((and (listp liste)(listp (second liste))
              (eq (first (second liste)) 'function)
              (EVENTUELL-METHODE-P nil (second (second liste))))
         `(,fname #',(transformiere_funktionsnamen (second (second liste))) ,idenfizierer
                 ,@ 
           (mapcar #'(lambda(was)
                      (transformiere klasse idenfizierer was))
                   (cddr liste))))
        (T (transformiere_methoden klasse idenfizierer liste)))
  )

(defun transformiere_funcall (klasse idenfizierer liste)
  (transformiere_apply klasse idenfizierer liste 'funcall)
  )

(defun transformiere_have (klasse idenfizierer liste)
  ;Das kann eigentlich nicht richtig sein einzige moeglichkeit:
  ;per hand in defclass anlegen und in setq transformieren, oder dynamik slot mixin benutzen
  (cond ((dynamic-slot-mixin-p klasse idenfizierer liste)
         ;merken
         (print `(mixin bei ,klasse wegen ,klasse idenfizierer ,liste))
         (list 'dynamic-have idenfizierer (second liste)
               (transformiere klasse idenfizierer (third liste))))
        (T 
         ;achtung in defclass aendern
         (print `(defclass aendern bei ,klasse wegen ,klasse idenfizierer ,liste))
         ;als slot vermerken
         ;merke slot bei klasse
         (merke klasse 'slots
                (cons (second (second liste))
                      (lese klasse 'slots)))
         (transformiere_setq
          klasse idenfizierer
                  (cons 'setq (cons (second (second liste))
                                    (cddr liste)))))))

(defun dynamic-slot-mixin-p (klasse idenfizierer liste)
  (declare (ignore idenfizierer))
  (eq :ja
      (b=ja-nein 
       (b=konkateniere-nach-string
        "Achtung, ein dynamisches have bei " klasse " Ausdruck " liste
        "Soll dynamic-have verwendet werden ==> selber dazumixen bei " klasse
        " Oder verndern sie selber das defclass")
        :ja-text "Mixin"
        :nein-text "defclass")))

(defun transformiere_do_do* (klasse identifiziere liste)
  ;Syntax (do (var*)(form form) forms) var ::= var oder (var) (var form) oder (var form form)
  (cons (first liste)
        (append
         (list 
          (mapcar #'(lambda(var)
                     (if (listp var)
                       (cons (first var)
                             (mapcar #'(lambda(form)
                                        (transformiere klasse identifiziere form))
                                     (rest var)))
                       var))
                  (second liste)))
         (list (list (transformiere klasse identifiziere (first (third liste)))
                     (transformiere klasse identifiziere (second (third liste)))))
         (mapcar #'(lambda(form)
                    (transformiere klasse identifiziere form))
                 (cdddr liste))
         )
        )
  )

(defun TRANSFORMIERE_DOLIST_DOTIMES (klasse identifiziere liste)
  ;Syntax (dotimes (von bis [zurueck]) forms)
  (let ((operator (first liste))
        (von (first (second liste)))
        (bis (second (second liste)))
        (zurueck (third (second liste))))
    (cons operator
          (cons
           (delete nil(list von (transformiere klasse identifiziere bis)
                 (transformiere klasse identifiziere zurueck)))
           (mapcar #'(lambda(form)
                      (transformiere klasse identifiziere form))
                   (cddr liste))
           )
          )
    )
  )
 
(defun transformiere_case (klasse identifiziere liste)
  ;syntax (case form paar*) paar* ::= (egal form*)
  (cons (first liste)
        (cons (transformiere klasse identifiziere (second liste))
              (mapcar #'(lambda(paar)
                         (if (stringp paar)
                           paar
                         (cons (first paar)
                               (mapcar #'(lambda(form)
                                          (transformiere klasse identifiziere form))
                                       (rest paar)))))
                      (cddr liste)))))
                               

(defun transformiere_cond (klasse identifiziere liste)
  ;Syntax: liste ::= (cond paar*)
  ;paar* ::= (Bedingung A1 ..An)
  (cons 'cond
        (mapcar #'(lambda(paar)
                   (if (stringp paar)
                     paar
                   (cons (transformiere klasse identifiziere (first paar))
                         (mapcar #'(lambda(aktion)
                                    (transformiere klasse identifiziere aktion))
                                 (rest paar))))
                   )
                (rest liste)))
  )

(defun transformiere_let_let* (klasse identifizierer liste)
  ;Syntax (let (var*) forms) var ::= v oder (v form)
  (append
   (cons (first liste) ;let, let*
         (list (mapcar #'(lambda(variablenpaar)
                    (if (listp variablenpaar)
                      (list (first variablenpaar)
                            (transformiere klasse identifizierer  (second variablenpaar)))
                      variablenpaar))
                 (second liste))))
   (mapcar #'(lambda(form)
              (transformiere klasse identifizierer form))
           (nthcdr 2 liste))))

(defun transformiere_self (klasse idenfizierer liste)
  (if (null (rest liste))
    idenfizierer
    (transformiere_methoden  klasse idenfizierer liste)))

(defun transformiere_proclaim (klasse idenfizierer liste)
  (declare (ignore klasse idenfizierer))
  (if (or (eql 'object-variable (first (cadadr liste)))
          (eql 'object-variables (first (cadadr liste))))
    ";proclaim object-variable ist in clos nicht mehr noetig"
    liste)
  )

(defun transformiere_declare (klasse idenfizierer liste)
  (declare (ignore klasse idenfizierer))
  (cons (first liste)
        (remove nil
                (mapcar #'(lambda(deklaration)
                           (if (eql 'object-variable
                                    (first deklaration))
                             nil
                             deklaration))
                        (cdr liste)))))

(defun transformiere_setq (klasse idenfizierer liste)
  (let ((ergebnis nil)
        (klassenvariablen (lese klasse 'slots))
        (alleklassenvariablen (lese_alle 'slots))
        )
    (do ((was (rest liste) (cddr was)))
        ((endp was) (if (= 1 (length ergebnis))
                      (first  ergebnis)
                      `(progn ,@ (reverse ergebnis))))
      (cond ((member (first was) klassenvariablen)
             (push `(setf ,(if *accessor_einbauen* 
                             `(,(first was) ,idenfizierer)
                             `(slot-value ,idenfizierer ',(first was)))
                          ,(transformiere klasse idenfizierer (second was))) ergebnis))
            ((member (first was) alleklassenvariablen)
             (push `(setf ,(if *accessor_einbauen* 
                             `(,(first was) ,idenfizierer)
                             `(slot-value ,idenfizierer ',(first was)))
                          ,(transformiere klasse idenfizierer (second was))) ergebnis))
            (t 
             (push `(setq ,(first was) 
                          ,(transformiere klasse idenfizierer (second was))) ergebnis)))
      )))

(defun transformiere_defobfun (klasse idenfizierer liste)
  (declare (ignore klasse idenfizierer))
  (let ((obfunname (first (second liste)))
        (obfunklasse (second (second liste)))
        (args (third liste))
        (body (nthcdr 3 liste)))
  `(defmethod ,(transformiere_funktionsnamen obfunname) ((,*name-of-instance*,obfunklasse) ,@ args)
     ,@(mapcar #'(lambda(was)
                  (transformiere obfunklasse *name-of-instance* was))
               body))))

(defun transformiere_defun (klasse idenfizierer liste)
  (declare (ignore idenfizierer))
  (let ((name (second liste))
        (args (third liste))
        (body (nthcdr 3 liste)))
  `(defun ,name ,args
     ,@(mapcar #'(lambda(was)
                  (transformiere klasse *name-of-instance* was))
               body))))

(defun transformiere_atom (klasse idenfizierer atom)
  (case atom
    ((my-view my-dialog) `(view-window ,idenfizierer))
    (t 
     (cond ((member atom (lese klasse 'slots))
            (if *accessor_einbauen*
              `(,atom ,idenfizierer)
              `(slot-value ,idenfizierer ',atom)))
           ((member atom (lese_alle 'slots))
            (if *accessor_einbauen*
              `(,atom ,idenfizierer)
              `(slot-value ,idenfizierer ',atom)))
           (T (transformiere_atome atom))))))

(defun transformiere_ask (klasse idenfizierer liste)
  (let ((was 
         (if (equal (second liste) '(self))
           (mapcar #'(lambda(was)
                      (transformiere klasse idenfizierer was))
                   (cddr liste))
           (let ((kv (transformiere klasse idenfizierer (second liste))))
             (mapcar #'(lambda(was)
                        (transformiere *name-of-unknown-object* kv was))
                     (cddr liste))
             ))))
           (if (= 1 (length was))
             (first was)
      `(progn
         ,@was))))

(defun transformiere_oneof (klasse idenfizierer liste)
  (if (listp (second liste))
  `(make-instance ,(transformiere klasse idenfizierer (second liste))
                  ,@(mapcar #'(lambda(was)
                               (transformiere klasse idenfizierer was))
                            (cddr liste)))
  `(make-instance ',(transformiere_klassennamen (second liste))
                  ,@(mapcar #'(lambda(was)
                               (transformiere klasse idenfizierer was))
                            (cddr liste)))))

(defun transformiere_objvar (klasse idenfizierer liste)
  (declare (ignore klasse))
  (if *accessor_einbauen*
    `(,(second liste) ,idenfizierer)
    `(slot-value ,idenfizierer ',(second liste))))
   
(defun eventuell-methode-p (klasse name)
  (when (null klasse)
    (setq klasse *name-of-unknown-object*))
  (or (member name (lese klasse 'obfuns))
      (member name *alte_neue_funktionsnamen*)
      (b=methode-p name )
      (and (eql klasse *name-of-unknown-object*)
           (member name (lese_alle 'obfuns)))
      )
  )

(defun transformiere_methoden (klasse idenfizierer liste)
  (cond ((eventuell-methode-p klasse (first liste))
         `(,(transformiere_funktionsnamen (first liste)) ,idenfizierer 
           ,@ 
           (mapcar #'(lambda(was)
                      (transformiere klasse idenfizierer was))
                   (rest liste)))
         )
        ((and (>= (length (b=erzeuge-string (first liste))) 5)
              (string-equal (subseq (b=erzeuge-string (first liste)) 0 5) "usual")
              )
         (let ((rest (transformiere klasse idenfizierer (rest liste))))
           (cond ((null rest)
                  `(apply #'call-next-method ,idenfizierer nil))
                 ((listp (first rest))
                  `(apply #'call-next-method ,idenfizierer ,@rest))
                 (t 
                  `(apply #'call-next-method ,idenfizierer ,(cons 'list rest)))))
         )
        (t
         `(,(transformiere_funktionsnamen (first liste))
           ,@ (mapcar #'(lambda(was)
                         (transformiere klasse idenfizierer was))
                      (rest liste)))
         ))
  )

(setq  *alte_neue_funktionsnamen*
  '(
    dialog-item-click-event-handler    view-click-event-handler
    Dialog-Item-Key-Event-Handler      view-Key-Event-Handler
    window-draw-contents               view-draw-contents
    mark-position                      buffer-position
    Window-Cursor-Mark                 fred-buffer
    inval-dialog-item                  invalidate-view
    dialog-item-draw                   view-draw-contents
    dialog-item-size                   view-size
    set-dialog-item-size               set-view-size
    dialog-item-position               view-position
    set-dialog-item-position           set-view-position
    dialog-item-nick-name              view-nick-name
    add-dialog-items                   add-subviews
    remove-dialog-items                remove-subviews
    find-named-dialog-items            view-named
    item-named                         view-named
    dialog-item-dialog                 view-container
    window-activate-event-handler      view-activate-event-handler
    window-deactivate-event-handler    view-deactivate-event-handler
    window-click-event-handler         view-click-event-handler
    window-mouse-position              view-mouse-position
    set-window-position                set-view-position
    window-position                    view-position
    set-window-size                    set-view-size
    window-size                        view-size
    dialog-item-font                   view-font
    window-font                        view-font
    markp                              buffer-mark-p
    buffer-char-font                   buffer-char-font-spec
    buffer-current-font                buffer-current-font-spec
    buffer-replace-font                buffer-replace-font-spec
    buffer-set-font                    buffer-set-font-spec
    ed-skip-fwd-wsp&comments           buffer-skip-fwd-wsp&comments
    dialog-item-default-size           view-default-size
    window-vpos                        fred-vpos
    window-line-vpos                   fred-line-vpos
    window-hpos                        fred-hpos
    window-update                      fred-update
    window-start-mark                  fred-display-start-mark
    window-buffer                      fred-buffer
    add-self-to-dialog                 install-view-in-window
    remove-self-from-dialog            remove-view-from-window
    ))


(defun transformiere_funktionsnamen (name)
  (getf *alte_neue_funktionsnamen* name name))

(defun transformiere_atome (name)
  (getf '(
          ;:dialog-item-action :dialog-item-action_#\'\(lambda\(ich\)_benutzen
          :dialog-item-width :view-width
          :Window-Size  :view-size
          :window-position :view-position
          :window-font :view-font
          :dialog-items :view-subviews
          :dialog-item-size :view-size
          :dialog-item-position :view-position
          :dialog-item-nick-name :view-nick-name
          :dialog-item-font :view-font
          :dialog-item-colors :part-color-list)
          name name))

(defun transformiere_klassennamen (name)
  (getf '(*dialog* dialog
          *window* window
          *view*   view
          *fred-window*  fred-window
          *menu* menu
          *menu-item* menu-item 
          *dialog-item* dialog-item
          *table-dialog-item* table-dialog-item
          *sequence-dialog-item* sequence-dialog-item
          *check-box-dialog-item* check-box-dialog-item
          *button-dialog-item* button-dialog-item
          *radio-button-dialog-item* radio-button-dialog-item
          *static-text-dialog-item* static-text-dialog-item
          *editable-text-dialog-item* editable-text-dialog-item
          )
        name name))
    